home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / clisp_c.zoo / places.lsp < prev    next >
Lisp/Scheme  |  1993-06-05  |  44KB  |  910 lines
  1. ; CLISP - PLACES.LSP
  2. ; CLISP-spezifisch: string-concat, %rplaca, %rplacd, store, %setelt, ...
  3.  
  4. (in-package "SYSTEM")
  5. ;-------------------------------------------------------------------------------
  6. ; Funktionen zur Definition und zum Ausnutzen von places:
  7. ;-------------------------------------------------------------------------------
  8. (defun get-setf-method-multiple-value (form &optional (env nil))
  9.   (do* ((newformbackup nil newform)
  10.         (newform form (macroexpand-1 newform env)))
  11.        ((eq newformbackup newform)
  12.         (error #+DEUTSCH "Das Argument muß eine 'SETF-place' sein, ist aber keine: ~S"
  13.                #+ENGLISH "Argument ~S is not a SETF place."
  14.                #+FRANCAIS "L'argument ~S doit représenter une place modifiable."
  15.                newform
  16.        ))
  17.     (when (symbolp newform)
  18.       (let ((storevar (gensym)))
  19.         (return (values nil
  20.                         nil
  21.                         `(,storevar)
  22.                         `(SETQ ,newform ,storevar)
  23.                         `,newform
  24.     ) ) )       )
  25.     (when (and (consp newform) (symbolp (car newform)))
  26.       (let ((plist-info (get (first newform) 'SYSTEM::SETF-EXPANDER)))
  27.         (when plist-info
  28.           (if (symbolp plist-info) ; Symbol kommt von kurzem DEFSETF
  29.             (return
  30.               (do* ((storevar (gensym))
  31.                     (tempvars nil (cons (gensym) tempvars))
  32.                     (tempforms nil)
  33.                     (formr (cdr newform) (cdr formr)))
  34.                    ((atom formr)
  35.                     (setq tempforms (nreverse tempforms))
  36.                     (values tempvars
  37.                             tempforms
  38.                             `(,storevar)
  39.                             `(,plist-info ,@tempvars ,storevar)
  40.                             `(,(first newform) ,@tempvars)
  41.                    ))
  42.                 (setq tempforms (cons (car formr) tempforms))
  43.             ) )
  44.             (let ((argcount (car plist-info)))
  45.               (if (eql argcount -5)
  46.                 (return ; (-5 . fun) kommt von DEFINE-SETF-METHOD
  47.                   (funcall (cdr plist-info) newform env)
  48.                 )
  49.                 (return ; (argcount . fun) kommt von langem DEFSETF
  50.                   (let ((access-form newform)
  51.                         (tempvars '())
  52.                         (tempforms '())
  53.                         (new-access-form '()))
  54.                     (let ((i 0)) ; Argumente-Zähler
  55.                       ; argcount = -1 falls keine Keyword-Argumente existieren
  56.                       ; bzw.     = Anzahl der einzelnen Argumente vor &KEY,
  57.                       ;          = nil nachdem diese abgearbeitet sind.
  58.                       (dolist (argform (cdr access-form))
  59.                         (when (eql i argcount) (setf argcount nil i 0))
  60.                         (if (and (null argcount) (evenp i))
  61.                           (if (keywordp argform)
  62.                             (push argform new-access-form)
  63.                             (error #+DEUTSCH "Das Argument ~S zu ~S sollte ein Keyword sein."
  64.                                    #+ENGLISH "The argument ~S to ~S should be a keyword."
  65.                                    #+FRANCAIS "L'argument ~S de ~S doit être un mot-clé."
  66.                                    argform (car access-form)
  67.                           ) )
  68.                           (let ((tempvar (gensym)))
  69.                             (push tempvar tempvars)
  70.                             (push argform tempforms)
  71.                             (push tempvar new-access-form)
  72.                         ) )
  73.                         (incf i)
  74.                     ) )
  75.                     (setq new-access-form
  76.                       (cons (car access-form) (nreverse new-access-form))
  77.                     )
  78.                     (let ((newval-var (gensym)))
  79.                       (values
  80.                         (nreverse tempvars)
  81.                         (nreverse tempforms)
  82.                         (list newval-var)
  83.                         (funcall (cdr plist-info) new-access-form newval-var)
  84.                         new-access-form
  85.             ) ) ) ) ) )
  86.     ) ) ) )
  87. ) )
  88. ;-------------------------------------------------------------------------------
  89. (defun get-setf-method (form &optional (env nil))
  90.   (multiple-value-bind (vars vals stores store-form access-form)
  91.       (get-setf-method-multiple-value form env)
  92.     (unless (and (consp stores) (null (cdr stores)))
  93.       (error #+DEUTSCH "Diese 'SETF-place' produziert mehrere 'Store-Variable': ~S"
  94.              #+ENGLISH "SETF place ~S produces more than one store variable."
  95.              #+FRANCAIS "La place modifiable ~S produit plusieurs variables de résultat."
  96.              form
  97.     ) )
  98.     (values vars vals stores store-form access-form)
  99. ) )
  100. ;-------------------------------------------------------------------------------
  101. (defun documentation (symbol doctype)
  102.   (unless (symbolp symbol)
  103.     (error #+DEUTSCH "~S: Das ist als erstes Argument unzulässig, da kein Symbol: ~S"
  104.            #+ENGLISH "~S: first argument ~S is illegal, not a symbol"
  105.            #+FRANCAIS "~S : Le premier argument ~S est invalide car ce n'est pas un symbole."
  106.            'documentation symbol
  107.   ) )
  108.   (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  109. )
  110. (defun SYSTEM::%SET-DOCUMENTATION (symbol doctype value)
  111.   (unless (symbolp symbol)
  112.     (error #+DEUTSCH "~S: Das ist als erstes Argument unzulässig, da kein Symbol: ~S"
  113.            #+ENGLISH "~S: first argument ~S is illegal, not a symbol"
  114.            #+FRANCAIS "~S : Le premier argument ~S est invalide car ce n'est pas un symbole."
  115.            'documentation symbol
  116.   ) )
  117.   (if (null value)
  118.     (when (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  119.       (remf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  120.     )
  121.     (setf (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype) value)
  122. ) )
  123. ;-------------------------------------------------------------------------------
  124. (defmacro push (item place &environment env)
  125.   (if (symbolp place)
  126.     `(SETQ ,place (CONS ,item ,place))
  127.     (let ((itemvar (gensym)))
  128.       (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  129.         (do* ((SM1r SM1 (cdr SM1r))
  130.               (SM2r SM2 (cdr SM2r))
  131.               (bindlist `((,itemvar ,item)) ))
  132.              ((null SM1r)
  133.               (push `(,(first SM3) (CONS ,itemvar ,SM5)) bindlist)
  134.               `(LET* ,(nreverse bindlist)
  135.                  ,SM4
  136.              ) )
  137.           (push `(,(first SM1r) ,(first SM2r)) bindlist)
  138. ) ) ) ) )
  139. ;-------------------------------------------------------------------------------
  140. (defmacro define-setf-method (accessfn lambdalist &body body &environment env)
  141.   (unless (symbolp accessfn)
  142.     (error #+DEUTSCH "Der Name der Access-Function muß ein Symbol sein und nicht ~S."
  143.            #+ENGLISH "The name of the access function must be a symbol, not ~S"
  144.            #+FRANCAIS "Le nom de la fonction d'accès doit être un symbole et non ~S."
  145.            accessfn
  146.   ) )
  147.   (multiple-value-bind (body-rest declarations docstring)
  148.       (system::parse-body body t env)
  149.     (if (null body-rest) (setq body-rest '(NIL)))
  150.     (let ((name (make-symbol (string-concat "SETF-" (symbol-name accessfn)))))
  151.       (multiple-value-bind (newlambdalist envvar) (remove-env-arg lambdalist name)
  152.         (let ((SYSTEM::%ARG-COUNT 0)
  153.               (SYSTEM::%MIN-ARGS 0)
  154.               (SYSTEM::%RESTP nil)
  155.               (SYSTEM::%LET-LIST nil)
  156.               (SYSTEM::%KEYWORD-TESTS nil)
  157.               (SYSTEM::%DEFAULT-FORM nil)
  158.              )
  159.           (SYSTEM::ANALYZE1 newlambdalist '(CDR SYSTEM::%LAMBDA-LIST)
  160.                             name 'SYSTEM::%LAMBDA-LIST
  161.           )
  162.           (if (null newlambdalist)
  163.             (push `(IGNORE SYSTEM::%LAMBDA-LIST) declarations)
  164.           )
  165.           (let ((lengthtest (sys::make-length-test 'SYSTEM::%LAMBDA-LIST))
  166.                 (mainform
  167.                   `(LET* ,(nreverse SYSTEM::%LET-LIST)
  168.                      ,@(if declarations `(,(cons 'DECLARE declarations)))
  169.